home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Camelot / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].zip / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].adf / XLisp-Stat / Functions / pressbutton.lsp < prev    next >
Text File  |  1990-10-11  |  3KB  |  70 lines
  1. ; book pp.313-316
  2.  
  3. (defproto button-overlay-proto
  4.           '(location title)
  5.           nil
  6.           graph-overlay-proto)
  7. (defmeth button-overlay-proto :location (&optional new)
  8.   (if new (setf (slot-value 'location) new))
  9.   (slot-value 'location))
  10. (defmeth button-overlay-proto :title (&optional new)
  11.   (if new (setf (slot-value 'title) new))
  12.   (slot-value 'title))
  13. (send button-overlay-proto :location '(0 0))
  14. (send button-overlay-proto :title "Button")
  15. (defmeth button-overlay-proto :size ()
  16.   (let* ((graph (send self :graph))
  17.          (title (send self :title))
  18.          (text-width (send graph :text-width title))
  19.          (side (send graph :text-ascent))
  20.          (gap (floor (/ side 2)))
  21.          (descent (send graph :text-descent))
  22.          (height (+ side descent (* 2 gap))))
  23.      (list (+ side (* 3 gap) text-width) height)))
  24. (defmeth button-overlay-proto :button-box ()
  25.   (let* ((graph (send self :graph))
  26.          (loc (send self :location))
  27.          (side (+ (send graph :text-ascent) (send graph :text-descent)))
  28.          (gap (floor (/ side 2))))
  29.    (list (+ gap (first loc)) (+ gap (second loc)) side side)))
  30. (defmeth button-overlay-proto :title-start ()
  31.   (let* ((graph (send self :graph))
  32.          (loc (send self :location))
  33.          (title (send self :title))
  34.          (side (send graph :text-ascent))
  35.          (gap (floor (/ side 2))))
  36.       (list (+ (* 2 gap) side (first loc))
  37.             (+ gap side (second loc)))))
  38. (defmeth button-overlay-proto :draw-button (&optional paint)
  39.   (let ((box (send self :button-box))
  40.         (graph (send self :graph)))
  41.      (apply #'send graph :erase-rect box)
  42.      (if paint
  43.           (apply #'send graph :paint-rect box)
  44.           (apply #'send graph :frame-rect box))))
  45. (defmeth button-overlay-proto :draw-title ()
  46.   (let ((graph (send self :graph))
  47.         (title (send self :title))
  48.         (title-xy (send self :title-start)))
  49.      (apply #'send graph :draw-string title title-xy)))
  50. (defmeth button-overlay-proto :redraw ()
  51.   (send self :draw-title)
  52.   (send self :draw-button))
  53. (defmeth button-overlay-proto :point-in-button (x y)
  54.   (let* ((box (send self :button-box))
  55.          (left (first box))
  56.          (top (second box))
  57.          (side (third box)))
  58.       (and (< left x (+ left side)) (< top y (+ top side)))))
  59. (defmeth button-overlay-proto :do-click (x y m1 m2)
  60.   (let ((graph (send self :graph)))
  61.     (when (send self :point-in-button x y)
  62.           (send self :draw-button t)
  63.           (send self :do-action (list m1 m2))
  64.           (send graph :while-button-down
  65.                 #'(lambda (x y) (send self :do-action nil))
  66.                 nil)
  67.           (send self :draw-button nil)
  68.           t)))
  69. (defmeth button-overlay-proto :do-action (x) nil)
  70.